home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / rules.pso < prev    next >
Encoding:
Text File  |  1992-02-17  |  12.7 KB  |  270 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
  2.  
  3. ; This file was generated by Pseudoscheme 2.8a
  4. ;  running in Lucid Common Lisp 4.0.1
  5. ;  from file /amd/night/b/jar/pseudo/rules.scm
  6.  
  7. (SCHI:BEGIN-TRANSLATED-FILE)
  8. (DEFUN REWRITE-SYNTAX-RULES
  9.        (.EXP R C)
  10.        (PROCESS-RULES (CDDR .EXP) (CADR .EXP) R C))
  11. (SCHI:SET-VALUE-FROM-FUNCTION 'REWRITE-SYNTAX-RULES
  12.                               'SCHEME::REWRITE-SYNTAX-RULES)
  13. (DEFUN PROCESS-RULES
  14.        (RULES SUBKEYWORDS R C)
  15.        (LET ((TAIL (FUNCALL R 'SCHEME::TAIL)))
  16.          (CONS (FUNCALL R 'SCHEME::LAMBDA)
  17.                (CONS '(SCHEME::%INPUT% SCHEME::%RENAME%
  18.                                        SCHEME::%COMPARE%)
  19.                      (LIST
  20.                        (CONS (FUNCALL R 'SCHEME::LET)
  21.                              (CONS
  22.                                (LIST
  23.                                  (CONS TAIL
  24.                                        (LIST
  25.                                          (CONS (FUNCALL R
  26.                                                         'SCHEME::CDR)
  27.                                                '(SCHEME::%INPUT%)))))
  28.                                (LIST
  29.                                  (CONS (FUNCALL R 'SCHEME::COND)
  30.                                        (APPEND
  31.                                          (MAPCAR
  32.                                            #'(LAMBDA (RULE)
  33.                                               (PROCESS-RULE RULE TAIL
  34.                                                SUBKEYWORDS R C))
  35.                                            RULES)
  36.                                          (LIST
  37.                                            (CONS (FUNCALL R
  38.                                                           'SCHEME::ELSE)
  39.                                                  '((SCHEME::SYNTAX-ERROR
  40.                                                     "use of macro doesn't match definition"
  41.                                                     SCHEME::%INPUT%))))))))))))))
  42. (SCHI:SET-VALUE-FROM-FUNCTION 'PROCESS-RULES
  43.                               'SCHEME::PROCESS-RULES)
  44. (DEFUN PROCESS-RULE
  45.        (RULE TAIL SUBKEYWORDS R C)
  46.        (DECLARE (SPECIAL NULL-RANK))
  47.        (IF (NOT (= (LENGTH RULE) 2))
  48.            (SYNTAX-ERROR "ill-formed rule" RULE))
  49.        (LET ((PATTERN (CAR RULE))
  50.              (TEMPLATE (CADR RULE)))
  51.          (LET ((ENV
  52.                  (PROCESS-PATTERN (CDR PATTERN)
  53.                                   TAIL
  54.                                   NULL-RANK
  55.                                   SUBKEYWORDS)))
  56.            (CONS (PROCESS-MATCH TAIL (CDR PATTERN) SUBKEYWORDS)
  57.                  (LIST
  58.                    (CONS (FUNCALL R 'SCHEME::LET*)
  59.                          (CONS
  60.                            (MAPCAR
  61.                              #'(LAMBDA (Z) (CONS (CAR Z) (LIST (CADR Z))))
  62.                              ENV)
  63.                            (LIST (PROCESS-TEMPLATE TEMPLATE ENV NULL-RANK)))))))))
  64. (SCHI:SET-VALUE-FROM-FUNCTION 'PROCESS-RULE
  65.                               'SCHEME::PROCESS-RULE)
  66. (LOCALLY (DECLARE (SPECIAL NULL-RANK))
  67.          (SETQ NULL-RANK 'NIL))
  68. (SCHI:SET-FUNCTION-FROM-VALUE 'NULL-RANK
  69.                               'SCHEME::NULL-RANK)
  70. (DEFUN PROCESS-MATCH
  71.        (INPUT PATTERN SUBKEYWORDS)
  72.        (IF (SCHI:TRUEP (NAME? PATTERN))
  73.            (IF (MEMBER PATTERN
  74.                        SUBKEYWORDS
  75.                        :TEST
  76.                        #'SCHI:SCHEME-EQUAL-P)
  77.                (CONS 'SCHEME::%COMPARE%
  78.                      (CONS INPUT
  79.                            (LIST (CONS 'SCHEME::QUOTE
  80.                                        (LIST PATTERN)))))
  81.                'T)
  82.            (IF (SCHI:TRUEP (ZERO-OR-MORE? PATTERN))
  83.                (PROCESS-LIST-MATCH INPUT
  84.                                    (CAR PATTERN)
  85.                                    SUBKEYWORDS)
  86.                (IF (SCHI:TRUEP (AT-LEAST-ONE? PATTERN))
  87.                    (CONS 'SCHEME::AND
  88.                          (CONS
  89.                            (CONS 'SCHEME::NOT
  90.                                  (LIST (CONS 'SCHEME::NULL?
  91.                                              (LIST INPUT))))
  92.                            (LIST
  93.                              (PROCESS-LIST-MATCH INPUT
  94.                                                  (CAR PATTERN)
  95.                                                  SUBKEYWORDS))))
  96.                    (IF (CONSP PATTERN)
  97.                        (CONS 'SCHEME::LET
  98.                              (CONS
  99.                                (LIST (CONS 'SCHEME::%TEMP%
  100.                                            (LIST INPUT)))
  101.                                (LIST
  102.                                  (CONS 'SCHEME::AND
  103.                                        (CONS '(SCHEME::PAIR? SCHEME::%TEMP%)
  104.                                              (CONS
  105.                                                (PROCESS-MATCH
  106.                                                  '(SCHEME::CAR SCHEME::%TEMP%)
  107.                                                  (CAR PATTERN)
  108.                                                  SUBKEYWORDS)
  109.                                                (LIST
  110.                                                  (PROCESS-MATCH
  111.                                                    '(SCHEME::CDR SCHEME::%TEMP%)
  112.                                                    (CDR PATTERN)
  113.                                                    SUBKEYWORDS))))))))
  114.                        (CONS 'SCHEME::EQUAL?
  115.                              (CONS INPUT
  116.                                    (LIST
  117.                                      (CONS 'SCHEME::QUOTE
  118.                                            (LIST PATTERN))))))))))
  119. (SCHI:SET-VALUE-FROM-FUNCTION 'PROCESS-MATCH
  120.                               'SCHEME::PROCESS-MATCH)
  121. (DEFUN PROCESS-LIST-MATCH
  122.        (INPUT PATTERN SUBKEYWORDS)
  123.        (CONS 'SCHEME::LET
  124.              (CONS 'SCHEME::LOOP
  125.                    (CONS (LIST (CONS 'SCHEME::L
  126.                                      (LIST INPUT)))
  127.                          (LIST
  128.                            (CONS 'SCHEME::OR
  129.                                  (CONS '(SCHEME::NULL? SCHEME::L)
  130.                                        (LIST
  131.                                          (CONS 'SCHEME::AND
  132.                                                (CONS
  133.                                                  '(SCHEME::PAIR? SCHEME::L)
  134.                                                  (CONS
  135.                                                    (PROCESS-MATCH
  136.                                                      '(SCHEME::CAR SCHEME::L)
  137.                                                      PATTERN
  138.                                                      SUBKEYWORDS)
  139.                                                    '((SCHEME::LOOP
  140.                                                       (SCHEME::CDR SCHEME::L))))))))))))))
  141. (SCHI:SET-VALUE-FROM-FUNCTION 'PROCESS-LIST-MATCH
  142.                               'SCHEME::PROCESS-LIST-MATCH)
  143. (DEFUN PROCESS-PATTERN
  144.        (PATTERN PATH RANK SUBKEYWORDS)
  145.        (IF (SCHI:TRUEP (NAME? PATTERN))
  146.            (IF (SCHI:TRUEP (NAME-MEMBER PATTERN SUBKEYWORDS))
  147.                'NIL
  148.                (LIST (LIST PATTERN PATH RANK)))
  149.            (IF (OR (SCHI:TRUEP (ZERO-OR-MORE? PATTERN))
  150.                    (SCHI:TRUEP (AT-LEAST-ONE? PATTERN)))
  151.                (LET ((TEMP 'SCHEME::%TEMP%))
  152.                  (CONS (CONS TEMP (LIST PATH))
  153.                        (MAPCAR
  154.                          #'(LAMBDA (Z)
  155.                             (CONS (CAR Z)
  156.                              (CONS
  157.                               (CONS 'SCHEME::MAP
  158.                                (CONS
  159.                                 (CONS 'SCHEME::LAMBDA
  160.                                  (CONS '(SCHEME::%INPUT%) (LIST (CADR Z))))
  161.                                 (LIST TEMP)))
  162.                               (LIST (CADDR Z)))))
  163.                          (PROCESS-PATTERN (CAR PATTERN)
  164.                                           'SCHEME::%INPUT%
  165.                                           (CONS (CADR PATTERN)
  166.                                                 RANK)
  167.                                           SUBKEYWORDS))))
  168.                (IF (CONSP PATTERN)
  169.                    (APPEND
  170.                      (PROCESS-PATTERN (CAR PATTERN)
  171.                                       (CONS 'SCHEME::CAR
  172.                                             (LIST PATH))
  173.                                       RANK
  174.                                       SUBKEYWORDS)
  175.                      (PROCESS-PATTERN (CDR PATTERN)
  176.                                       (CONS 'SCHEME::CDR
  177.                                             (LIST PATH))
  178.                                       RANK
  179.                                       SUBKEYWORDS))
  180.                    'NIL))))
  181. (SCHI:SET-VALUE-FROM-FUNCTION 'PROCESS-PATTERN
  182.                               'SCHEME::PROCESS-PATTERN)
  183. (DEFUN PROCESS-TEMPLATE
  184.        (TEMPLATE ENV RANK)
  185.        (IF (SCHI:TRUEP (NAME? TEMPLATE))
  186.            (LET ((PROBE (NAME-ASSOC TEMPLATE ENV)))
  187.              (IF (SCHI:TRUEP PROBE)
  188.                  (IF (SCHI:SCHEME-EQUAL-P (CADDR PROBE) RANK)
  189.                      TEMPLATE
  190.                      (SYNTAX-ERROR "syntax-rules: template rank error"
  191.                                    TEMPLATE))
  192.                  (CONS 'SCHEME::%RENAME%
  193.                        (LIST (CONS 'SCHEME::QUOTE
  194.                                    (LIST TEMPLATE))))))
  195.            (IF (OR (SCHI:TRUEP (ZERO-OR-MORE? TEMPLATE))
  196.                    (SCHI:TRUEP (AT-LEAST-ONE? TEMPLATE)))
  197.                (LET ((VARS (FREE-TEMPLATE-VARS (CAR TEMPLATE)
  198.                                                ENV
  199.                                                'NIL)))
  200.                  (IF (NULL VARS)
  201.                      (SYNTAX-ERROR "ill-formed template"
  202.                                    TEMPLATE)
  203.                      (CONS 'SCHEME::MAP
  204.                            (CONS
  205.                              (CONS 'SCHEME::LAMBDA
  206.                                    (CONS VARS
  207.                                          (LIST
  208.                                            (PROCESS-TEMPLATE (CAR TEMPLATE)
  209.                                                              ENV
  210.                                                              (CONS
  211.                                                                (CADR TEMPLATE)
  212.                                                                RANK)))))
  213.                              VARS))))
  214.                (IF (CONSP TEMPLATE)
  215.                    (CONS 'SCHEME::CONS
  216.                          (CONS (PROCESS-TEMPLATE (CAR TEMPLATE)
  217.                                                  ENV
  218.                                                  RANK)
  219.                                (LIST
  220.                                  (PROCESS-TEMPLATE (CDR TEMPLATE)
  221.                                                    ENV
  222.                                                    RANK))))
  223.                    (CONS 'SCHEME::QUOTE
  224.                          (LIST TEMPLATE))))))
  225. (SCHI:SET-VALUE-FROM-FUNCTION 'PROCESS-TEMPLATE
  226.                               'SCHEME::PROCESS-TEMPLATE)
  227. (DEFUN FREE-TEMPLATE-VARS
  228.        (TEMPLATE ENV FREE)
  229.        (IF (SCHI:TRUEP (NAME? TEMPLATE))
  230.            (IF (AND (SCHI:TRUEP (NAME-ASSOC TEMPLATE ENV))
  231.                     (NOT (SCHI:TRUEP (NAME-MEMBER TEMPLATE FREE))))
  232.                (CONS TEMPLATE FREE)
  233.                FREE)
  234.            (IF (OR (SCHI:TRUEP (ZERO-OR-MORE? TEMPLATE))
  235.                    (SCHI:TRUEP (AT-LEAST-ONE? TEMPLATE)))
  236.                (FREE-TEMPLATE-VARS (CADR TEMPLATE) ENV FREE)
  237.                (IF (CONSP TEMPLATE)
  238.                    (FREE-TEMPLATE-VARS (CAR TEMPLATE)
  239.                                        ENV
  240.                                        (FREE-TEMPLATE-VARS (CDR TEMPLATE)
  241.                                                            ENV
  242.                                                            FREE))
  243.                    FREE))))
  244. (SCHI:SET-VALUE-FROM-FUNCTION 'FREE-TEMPLATE-VARS
  245.                               'SCHEME::FREE-TEMPLATE-VARS)
  246. (DEFUN CHECK-CADR
  247.        (SYMS)
  248.        #'(LAMBDA (PATTERN)
  249.           (IF (CONSP PATTERN)
  250.            (IF (CONSP (CDR PATTERN))
  251.             (IF (MEMBER (CADR PATTERN) SYMS :TEST #'EQ)
  252.              (OR (NULL (CDDR PATTERN))
  253.               (SYNTAX-ERROR "segment matching not implemented" PATTERN))
  254.              SCHI:FALSE)
  255.             SCHI:FALSE)
  256.            SCHI:FALSE)))
  257. (SCHI:SET-VALUE-FROM-FUNCTION 'CHECK-CADR
  258.                               'SCHEME::CHECK-CADR)
  259. (DEFUN AT-LEAST-ONE? (X) SCHI:FALSE)
  260. (SCHI:SET-VALUE-FROM-FUNCTION 'AT-LEAST-ONE?
  261.                               'SCHEME::AT-LEAST-ONE?)
  262. (LOCALLY (DECLARE (SPECIAL ZERO-OR-MORE?))
  263.          (SETQ ZERO-OR-MORE? (CHECK-CADR
  264.                                (LIST
  265.                                  (VALUES (INTERN "..."
  266.                                                  SCHI:SCHEME-PACKAGE))
  267.                                  'SCHEME::---))))
  268. (SCHI:SET-FUNCTION-FROM-VALUE 'ZERO-OR-MORE?
  269.                               'SCHEME::ZERO-OR-MORE?)
  270.